home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / menu enhancements / new-pic.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  5.9 KB  |  140 lines  |  [TEXT/CCL2]
  1. (in-package ccl)
  2. (require 'graph-window)
  3. (export 'gdemo-window)
  4. (use-package '(:menus :common-lisp :common-lisp-user :ccl))
  5.  
  6. (defun get-hidden-box ()
  7.   (menus::get-wmgr))
  8.  
  9. (defclass gdemo-window (menus:marking-menu-view pic-window)
  10.   ()
  11.   (:default-initargs
  12.     :window-title "Graphic"
  13.     :close-box-p t
  14.     :auto-size t))
  15.  
  16. (defmethod do-graphic-demo ((view gdemo-window))
  17.   ;; creates a random drawing in a random-sized view
  18.   ;; the drawing contains a filled oval and rectangle and a line
  19.   (let* ((oval-corner (random-point 200 200 :xmin 60 :ymin 60))
  20.          (oval-h (truncate (point-h oval-corner) 2))
  21.          (oval-v (truncate (point-h oval-corner) 2))
  22.          (rect-corner (random-point (+ oval-h 100) (+ oval-v 200)
  23.                                     :xmin oval-h
  24.                                     :ymin oval-v))
  25.          (line-end (random-point 200 500 :xmin 150 :ymin 150))
  26.          (xmax (apply #'max (mapcar #'point-h (list oval-corner rect-corner line-end))))
  27.          (ymax (apply #'max (mapcar #'point-v (list oval-corner rect-corner line-end))))
  28.          (new-size (add-points (make-point xmax ymax)
  29.                                #@(5 5)))
  30.          my-view
  31.          picture)
  32.     (setq my-view (get-hidden-box))
  33.     (with-focused-view my-view
  34.       (rlet ((r :rect :topLeft #@(0 0) :bottomRight new-size))
  35.         (setq picture (#_OpenPicture :ptr r))
  36.         (fill-oval my-view *gray-pattern* #@(50 50) oval-corner)
  37.         (frame-oval my-view #@(50 50) oval-corner)
  38.         (set-pen-mode my-view :patxor)
  39.         (fill-rect my-view *light-gray-pattern* (make-point oval-h oval-v) rect-corner)
  40.         (set-pen-mode my-view :patcopy)
  41.         (frame-rect my-view  (make-point oval-h oval-v) rect-corner)
  42.         (move-to my-view (random-point 150 150))
  43.         (line-to my-view line-end)
  44.         (#_closePicture)))
  45.     (store-picture view picture)))
  46.  
  47. (defmethod initialize-instance :after ((menus:marking-menu-view gdemo-window) &rest initargs)
  48.   (declare (ignore initargs))
  49.   (let ((enlarge (make-instance 'window-menu-item
  50.                                 :menu-item-title "Enlarge"
  51.                                 :disabled t))
  52.         
  53.         (reduce (make-instance 'window-menu-item
  54.                                :menu-item-title "Reduce"
  55.                                :disabled t))
  56.         
  57.         (new-pict (make-instance 'window-menu-item
  58.                                  :menu-item-title "New"))
  59.         
  60.         (normal-size (make-instance 'window-menu-item
  61.                                     :menu-item-title "Normal"
  62.                                     :disabled t))
  63.         
  64.         (clear (make-instance 'window-menu-item
  65.                               :menu-item-title "Clear"
  66.                               :disabled t))
  67.         
  68.         (size (make-instance 'menu-item
  69.                              :menu-item-title "1 x"
  70.                              :disabled t))
  71.         
  72.         (close (make-instance 'window-menu-item
  73.                               :menu-item-title "Close"
  74.                               :menu-item-action
  75.                               #'(lambda (item)
  76.                                   (window-close (menus:containing-view item))))))
  77.     (cl-user::get-menu-options menus::marking-menu-view)
  78.     
  79.     (add-menu-items menus:marking-menu-view enlarge new-pict normal-size
  80.                     (make-instance 'menus:empty-menu-item)
  81.                     reduce size clear close)
  82.     
  83.     (setf (menu-item-action-function enlarge)
  84.           #'(lambda (item)
  85.               (let* ((view (menus:containing-view item))
  86.                      (scale (zoom-in view)))
  87.                 (if scale
  88.                   (set-menu-item-title size 
  89.                                        (progn (if (= scale 1)
  90.                                                 (menu-item-disable normal-size)
  91.                                                 (menu-item-enable normal-size))
  92.                                               (menu-item-enable reduce)
  93.                                               (format nil "~s x" scale)))
  94.                   (menu-item-disable enlarge))))
  95.           
  96.           (menu-item-action-function reduce)
  97.           #'(lambda (item)
  98.               (let* ((view (menus:containing-view item))
  99.                      (scale (zoom-out view)))
  100.                 (if scale
  101.                   (set-menu-item-title size 
  102.                                        (progn 
  103.                                          (if (= scale 1)
  104.                                            (menu-item-disable normal-size)
  105.                                            (menu-item-enable normal-size))
  106.                                          (menu-item-enable enlarge)
  107.                                          (format nil "~s x" scale)))
  108.                   (menu-item-disable reduce))))
  109.           
  110.           (menu-item-action-function new-pict)
  111.           #'(lambda (item)
  112.               (do-graphic-demo (menus:containing-view item))
  113.               (menu-item-disable normal-size)
  114.               (set-menu-item-title size (format nil "1 x"))
  115.               (mapc #'menu-item-enable (list reduce enlarge clear)))
  116.           
  117.           (menu-item-action-function clear)
  118.           #'(lambda (item)
  119.               (clear (menus:containing-view item))
  120.               (menu-item-disable normal-size)
  121.               (set-menu-item-title size (format nil "Empty"))
  122.               (mapc #'menu-item-disable (list reduce enlarge clear normal-size))
  123.               nil)
  124.           
  125.           (menu-item-action-function normal-size)
  126.           #'(lambda (item)
  127.               (normal-size (menus:containing-view item))
  128.               (set-menu-item-title size (format nil "1 x"))
  129.               (menu-item-disable normal-size)
  130.               (mapc #'menu-item-enable (list reduce enlarge))
  131.               nil))))
  132.  
  133. (defun random-point (xmax ymax &key xmin ymin)
  134.   (let ((x (random (if xmin (- xmax xmin) xmax)))
  135.         (y (random (if ymin (- ymax ymin) ymax))))
  136.     (when xmin (incf x xmin))
  137.     (when ymin (incf y ymin))
  138.     (make-point x y)))
  139.  
  140.